home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / 1.6.0 / scripts / lint < prev    next >
Encoding:
Text File  |  2004-01-06  |  9.7 KB  |  320 lines
  1. #!/bin/sh
  2. # aside from this initial boilerplate, this is actually -*- scheme -*- code
  3. main='(module-ref (resolve-module '\''(scripts lint)) '\'main')'
  4. exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
  5. !#
  6. ;;; lint --- Preemptive checks for coding errors in Guile Scheme code
  7.  
  8. ;;     Copyright (C) 2002 Free Software Foundation, Inc.
  9. ;;
  10. ;; This program is free software; you can redistribute it and/or
  11. ;; modify it under the terms of the GNU General Public License as
  12. ;; published by the Free Software Foundation; either version 2, or
  13. ;; (at your option) any later version.
  14. ;;
  15. ;; This program is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19. ;;
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with this software; see the file COPYING.  If not, write to
  22. ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  23. ;; Boston, MA 02111-1307 USA
  24.  
  25. ;;; Author: Neil Jerram
  26.  
  27. ;;; Commentary:
  28.  
  29. ;; Usage: lint FILE1 FILE2 ...
  30. ;;
  31. ;; Perform various preemptive checks for coding errors in Guile Scheme
  32. ;; code.
  33. ;;
  34. ;; Right now, there is only one check available, for unresolved free
  35. ;; variables.  The intention is that future lint-like checks will be
  36. ;; implemented by adding to this script file.
  37. ;;
  38. ;; Unresolved free variables
  39. ;; -------------------------
  40. ;;
  41. ;; Free variables are those whose definitions come from outside the
  42. ;; module under investigation.  In Guile, these definitions are
  43. ;; imported from other modules using `#:use-module' forms.
  44. ;;
  45. ;; This tool scans the specified files for unresolved free variables -
  46. ;; i.e. variables for which you may have forgotten the appropriate
  47. ;; `#:use-module', or for which the module that is supposed to export
  48. ;; them forgot to.
  49. ;;
  50. ;; It isn't guaranteed that the scan will find absolutely all such
  51. ;; errors.  Quoted (and quasiquoted) expressions are skipped, since
  52. ;; they are most commonly used to describe constant data, not code, so
  53. ;; code that is explicitly evaluated using `eval' will not be checked.
  54. ;; For example, the `unresolved-var' in `(eval 'unresolved-var
  55. ;; (current-module))' would be missed.
  56. ;;
  57. ;; False positives are also possible.  Firstly, the tool doesn't
  58. ;; understand all possible forms of implicit quoting; in particular,
  59. ;; it doesn't detect and expand uses of macros.  Secondly, it picks up
  60. ;; explicit compatibility code like `(if (defined? 'x) (define y x))'.
  61. ;; Thirdly, there are occasional oddities like `next-method'.
  62. ;; However, the number of false positives for realistic code is
  63. ;; hopefully small enough that they can be individually considered and
  64. ;; ignored.
  65. ;;
  66. ;; Example
  67. ;; -------
  68. ;;
  69. ;; Note: most of the unresolved variables found in this example are
  70. ;; false positives, as you would hope.  => scope for improvement.
  71. ;;
  72. ;; $ guile-tools lint `guile-tools`
  73. ;; No unresolved free variables in PROGRAM
  74. ;; No unresolved free variables in autofrisk
  75. ;; No unresolved free variables in display-commentary
  76. ;; Unresolved free variables in doc-snarf:
  77. ;;        doc-snarf-version
  78. ;; No unresolved free variables in frisk
  79. ;; No unresolved free variables in generate-autoload
  80. ;; No unresolved free variables in lint
  81. ;; No unresolved free variables in punify
  82. ;; No unresolved free variables in read-scheme-source
  83. ;; Unresolved free variables in snarf-check-and-output-texi:
  84. ;;        name
  85. ;;        pos
  86. ;;        line
  87. ;;        x
  88. ;;        rest
  89. ;;        ...
  90. ;;        do-argpos
  91. ;;        do-command
  92. ;;        do-args
  93. ;;        type
  94. ;;        num
  95. ;;        file
  96. ;;        do-arglist
  97. ;;        req
  98. ;;        opt
  99. ;;        var
  100. ;;        command
  101. ;;        do-directive
  102. ;;        s
  103. ;;        ?
  104. ;; No unresolved free variables in use2dot
  105.  
  106. ;;; Code:
  107.  
  108. (define-module (scripts lint)
  109.   #:use-module (ice-9 common-list)
  110.   #:use-module (ice-9 format)
  111.   #:export (lint))
  112.  
  113. (define (lint filename)
  114.   (let ((module-name (scan-file-for-module-name filename))
  115.     (free-vars (uniq (scan-file-for-free-variables filename))))
  116.     (let ((module (resolve-module module-name))
  117.       (all-resolved? #t))
  118.       (let loop ((free-vars free-vars))
  119.     (or (null? free-vars)
  120.         (begin
  121.           (catch #t
  122.         (lambda ()
  123.           (eval (car free-vars) module))
  124.         (lambda args
  125.           (if all-resolved?
  126.               (format #t
  127.                   "Unresolved free variables in ~A:\n"
  128.                   filename))
  129.           (write-char #\tab)
  130.           (write (car free-vars))
  131.           (newline)
  132.           (set! all-resolved? #f)))
  133.           (loop (cdr free-vars)))))
  134.       (if all-resolved?
  135.       (format #t
  136.           "No unresolved free variables in ~A\n"
  137.           filename)))))
  138.  
  139. (define (scan-file-for-module-name filename)
  140.   (with-input-from-file filename
  141.     (lambda ()
  142.       (let loop ((x (read)))
  143.     (cond ((eof-object? x) #f)
  144.           ((and (pair? x)
  145.             (eq? (car x) 'define-module))
  146.            (cadr x))
  147.           (else (loop (read))))))))
  148.  
  149. (define (scan-file-for-free-variables filename)
  150.   (with-input-from-file filename
  151.     (lambda ()
  152.       (let loop ((x (read)) (fvlists '()))
  153.     (if (eof-object? x)
  154.         (apply append fvlists)
  155.         (loop (read) (cons (detect-free-variables x '()) fvlists)))))))
  156.  
  157. ; guile> (detect-free-variables '(let ((a 1)) a) '())
  158. ; ()
  159. ; guile> (detect-free-variables '(let ((a 1)) b) '())
  160. ; (b)
  161. ; guile> (detect-free-variables '(let ((a 1) (b a)) b) '())
  162. ; (a)
  163. ; guile> (detect-free-variables '(let* ((a 1) (b a)) b) '())
  164. ; ()
  165. ; guile> (detect-free-variables '(define a 1) '())
  166. ; ()
  167. ; guile> (detect-free-variables '(define a b) '())
  168. ; (b)
  169. ; guile> (detect-free-variables '(define (a b c) b) '())
  170. ; ()
  171. ; guile> (detect-free-variables '(define (a b c) e) '())
  172. ; (e)
  173.  
  174. (define (detect-free-variables x locals)
  175.   ;; Given an expression @var{x} and a list @var{locals} of local
  176.   ;; variables (symbols) that are in scope for @var{x}, return a list
  177.   ;; of free variable symbols.
  178.   (cond ((symbol? x)
  179.      (if (memq x locals) '() (list x)))
  180.  
  181.     ((pair? x)
  182.      (case (car x)
  183.        ((define-module define-generic quote quasiquote)
  184.         ;; No code of interest in these expressions.
  185.         '())
  186.  
  187.        ((let letrec)
  188.         ;; Check for named let.  If there is a name, transform the
  189.         ;; expression so that it looks like an unnamed let with
  190.         ;; the name as one of the bindings.
  191.         (if (symbol? (cadr x))
  192.         (set-cdr! x (cons (cons (list (cadr x) #f) (caddr x))
  193.                   (cdddr x))))
  194.         ;; Unnamed let processing.
  195.         (let ((letrec? (eq? (car x) 'letrec))
  196.           (locals-for-let-body (append locals (map car (cadr x)))))
  197.           (append (apply append
  198.                  (map (lambda (binding)
  199.                     (detect-free-variables (cadr binding)
  200.                                (if letrec?
  201.                                    locals-for-let-body
  202.                                    locals)))
  203.                   (cadr x)))
  204.               (apply append
  205.                  (map (lambda (bodyform)
  206.                     (detect-free-variables bodyform
  207.                                locals-for-let-body))
  208.                   (cddr x))))))
  209.  
  210.        ((let* and-let*)
  211.         ;; Handle bindings recursively.
  212.         (if (null? (cadr x))
  213.         (apply append
  214.                (map (lambda (bodyform)
  215.                   (detect-free-variables bodyform locals))
  216.                 (cddr x)))
  217.         (append (detect-free-variables (cadr (caadr x)) locals)
  218.             (detect-free-variables `(let* ,(cdadr x) ,@(cddr x))
  219.                            (cons (caaadr x) locals)))))
  220.  
  221.        ((define define-public define-macro)
  222.         (if (pair? (cadr x))
  223.         (begin
  224.           (set! locals (cons (caadr x) locals))
  225.           (detect-free-variables `(lambda ,(cdadr x) ,@(cddr x))
  226.                      locals))
  227.         (begin
  228.           (set! locals (cons (cadr x) locals))
  229.           (detect-free-variables (caddr x) locals))))
  230.  
  231.        ((lambda lambda*)
  232.         (let ((locals-for-lambda-body (let loop ((locals locals)
  233.                              (args (cadr x)))
  234.                         (cond ((null? args) locals)
  235.                           ((pair? args)
  236.                            (loop (cons (car args) locals)
  237.                              (cdr args)))
  238.                           (else
  239.                            (cons args locals))))))
  240.           (apply append
  241.              (map (lambda (bodyform)
  242.                 (detect-free-variables bodyform
  243.                            locals-for-lambda-body))
  244.               (cddr x)))))
  245.  
  246.        ((receive)
  247.         (let ((locals-for-receive-body (append locals (cadr x))))
  248.           (apply append
  249.              (detect-free-variables (caddr x) locals)
  250.              (map (lambda (bodyform)
  251.                 (detect-free-variables bodyform
  252.                            locals-for-receive-body))
  253.               (cdddr x)))))
  254.  
  255.        ((define-method define*)
  256.         (let ((locals-for-method-body (let loop ((locals locals)
  257.                              (args (cdadr x)))
  258.                         (cond ((null? args) locals)
  259.                           ((pair? args)
  260.                            (loop (cons (if (pair? (car args))
  261.                                    (caar args)
  262.                                    (car args))
  263.                                    locals)
  264.                              (cdr args)))
  265.                           (else
  266.                            (cons args locals))))))
  267.           (apply append
  268.              (map (lambda (bodyform)
  269.                 (detect-free-variables bodyform
  270.                            locals-for-method-body))
  271.               (cddr x)))))
  272.  
  273.        ((define-class)
  274.         ;; Avoid picking up slot names at the start of slot
  275.         ;; definitions.
  276.         (apply append
  277.            (map (lambda (slot/option)
  278.               (detect-free-variables-noncar (if (pair? slot/option)
  279.                                 (cdr slot/option)
  280.                                 slot/option)
  281.                             locals))
  282.             (cdddr x))))
  283.  
  284.        ((case)
  285.         (apply append
  286.            (detect-free-variables (cadr x) locals)
  287.            (map (lambda (case)
  288.               (detect-free-variables (cdr case) locals))
  289.             (cddr x))))
  290.             
  291.        ((unquote unquote-splicing else =>)
  292.         (detect-free-variables-noncar (cdr x) locals))
  293.  
  294.        (else (append (detect-free-variables (car x) locals)
  295.              (detect-free-variables-noncar (cdr x) locals)))))
  296.  
  297.     (else '())))
  298.  
  299. (define (detect-free-variables-noncar x locals)
  300.   ;; Given an expression @var{x} and a list @var{locals} of local
  301.   ;; variables (symbols) that are in scope for @var{x}, return a list
  302.   ;; of free variable symbols.
  303.   (cond ((symbol? x)
  304.      (if (memq x locals) '() (list x)))
  305.  
  306.     ((pair? x)
  307.      (case (car x)
  308.        ((=>)
  309.         (detect-free-variables-noncar (cdr x) locals))
  310.  
  311.        (else (append (detect-free-variables (car x) locals)
  312.              (detect-free-variables-noncar (cdr x) locals)))))
  313.  
  314.     (else '())))
  315.  
  316. (define (main . files)
  317.   (for-each lint files))
  318.  
  319. ;;; lint ends here
  320.